home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / mpfeel.lha / MPFeel / Modules / case.em < prev    next >
Lisp/Scheme  |  1992-10-06  |  4KB  |  131 lines
  1. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2. ;;                                                                           ;;
  3. ;;  EuLisp Module                     Copyright (C) University of Bath 1991  ;;
  4. ;;                                                                           ;;
  5. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  6.  
  7. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  8. ;;                                                                           ;;
  9. ;;   EuLisp Module  -   Copyright (C) Codemist and University of Bath 1990   ;;
  10. ;;                                                                           ;;
  11. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  12.  
  13. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  14. ;;                                                                           ;;
  15. ;; Name: case                                                                ;;
  16. ;;                                                                           ;;
  17. ;; Author: Keith Playford                                                    ;;
  18. ;;                                                                           ;;
  19. ;; Date: 20 August 1990                                                      ;;
  20. ;;                                                                           ;;
  21. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  22.  
  23. ;;
  24.  
  25. ;; Change Log:
  26. ;;   Version 1.0 (20/8/90)
  27.  
  28. ;;
  29.  
  30. (defmodule case
  31.  
  32.   (standard) ()
  33.  
  34.   (defun error (m c . i)
  35.     (signal (make-condition c 'message m) ()))
  36.  
  37.   (defconstant *wild-card* 'else)
  38.  
  39.   (defconstant *case-error* clock-tick)
  40.  
  41.   (deflocal free-variables ())
  42.  
  43.   (defun add-free-var (sym) 
  44.     (setq free-variables (cons sym free-variables))
  45.     ())
  46.  
  47.   (defun reset-free-var () 
  48.     (setq free-variables ())
  49.     ())
  50.  
  51.   ;; Match cases...
  52.  
  53.   (defun symbol-matcher (sym) 
  54.     (cond ((eq sym *wild-card*) (lambda (x) t))
  55.       (t (add-free-var sym)
  56.          `(lambda (@case-exp-part@) (setq ,sym @case-exp-part@) t))))
  57.  
  58.   (defun constant-matcher (c)
  59.     `(lambda (@case-exp-part@) (equal @case-exp-part@ ,c)))
  60.  
  61.   (defun sublist-matcher (l)
  62.     (cond ((null l) (constant-matcher nil))
  63.       (t `(lambda (@case-exp-part@)
  64.         (and (,(pattern-matcher (car l)) (car @case-exp-part@))
  65.              (,(sublist-matcher (cdr l)) (cdr @case-exp-part@)))))))
  66.  
  67.   (defun list-matcher (l)
  68.     (let ((pats (cdr l)))
  69.       (cond ((consp pats)
  70.          `(lambda (@case-exp-part@)
  71.         (and (consp @case-exp-part@)
  72.              (= (list-length @case-exp-part@) ,(list-length pats))
  73.              (,(sublist-matcher pats) @case-exp-part@))))
  74.         (t (error "case: empty list pattern" *case-error*)))))
  75.  
  76.   (defun cons-matcher (l)
  77.     (let ((pats (cdr l)))
  78.       (cond ((and (consp pats) (= (list-length pats) 2))
  79.          `(lambda (@case-exp-part@)
  80.         (and (consp @case-exp-part@)
  81.              (,(pattern-matcher (car l)) (car @case-exp-part@))
  82.              (,(pattern-matcher (cdr l)) (cdr @case-exp-part@))))))))
  83.  
  84.   (defun vector-matcher (v)
  85.     (let ((pats (cdr l)))
  86.       
  87.  
  88.   (defun pattern-matcher (pat)
  89.     (cond ((consp pat)
  90.        (cond ((eqcar pat 'quote) (constant-matcher pat))
  91.          ((eqcar pat 'list) (list-matcher pat))
  92.          ((eqcar pat 'cons) (cons-matcher pat))
  93.          (t (error "case: unknown structure" *case-error*))))
  94.       (t (cond ((symbolp pat) (symbol-matcher pat))
  95.            (t (constant-matcher pat))))))
  96.  
  97.   (defun vector-matcher (v))
  98.   ;; Matcher generator...
  99.  
  100.   (defun case-matcher (case) 
  101.     (reset-free-var)
  102.     (let ((pat (car case))
  103.       (vals (cdr case)))
  104.       (let ((forms (pattern-matcher pat)))
  105.     `(((lambda ,free-variables
  106.         (if (,forms @case-exp@)
  107.           (progn
  108.         (setq @case-result@ (progn ,@vals))
  109.         t)
  110.           nil))
  111.        ,@(mapcar (lambda (a) ()) free-variables)) nil))))
  112.  
  113.   (defun case-matchers (cases) 
  114.     (cond ((null cases) (list '(t (print "NO MATCH"))))
  115.       (t (cons (case-matcher (car cases)) 
  116.            (case-matchers (cdr cases))))))
  117.     
  118.      
  119.   ;; Interface macro...
  120.  
  121.   (defmacro case (exp . cases)
  122.     `(let ((@case-exp@ ,exp)
  123.        (@case-result@ ()))
  124.        (cond
  125.      ,@(case-matchers cases))
  126.        @case-result@))
  127.  
  128.   (export case)
  129.  
  130. )
  131.